home *** CD-ROM | disk | FTP | other *** search
/ United Public Domain Gold 2 / United Public Domain Gold 2.iso / utilities / pu659.dms / pu659.adf / Scion / ARexx / GEDCOM2Scion.rexx < prev    next >
OS/2 REXX Batch file  |  1994-05-21  |  21KB  |  730 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  *                                                                          *
  4.  * $VER: GEDCOM2Scion.rexx 1.08 (1 Mar 1994)
  5.  *                                                                          *
  6.  *                      Written by Freddy Ariës                             *
  7.  *                                                                          *
  8.  * This program was created to import GEDCOM data into the Scion database.  *
  9.  * It is still very basic and not user-friendly at all.                     *
  10.  * I assume it will only be able to parse the most basic GEDCOM files, and  *
  11.  * I can't even guarantee that it will handle these correctly...            *
  12.  *                                                                          *
  13.  * Even though this script does no parsing of dates, it's safer if they are *
  14.  * in the exact format "DD MMM YYYY".                                       *
  15.  * All unrecognized fields or fields that Scion doesn't use, are skipped.   *
  16.  * The database must be running for this AREXX script to work.              *
  17.  * NOTE: The program generates a file DATABASE.err (where DATABASE is the   *
  18.  *  name of the current Scion database), containing parsing info about      *
  19.  *  which lines were skipped and which non-fatal errors were encountered.   *
  20.  *  It may be a good idea to read this file!                                *
  21.  *                                                                          *
  22.  * TO DO:                                                                   *
  23.  *  - Better solution for the user-defined PERSONAL and FAMILY fields       *
  24.  *    (PERSUSER1, PERSUSER2, PERSUSER3, FAMUSER1, FAMUSER2)                 *
  25.  *    Current solution: assume defaults                                     *
  26.  *  - Better parsing of dates                                               *
  27.  *    Recognition and use of ABT, BEF, AFT notations                        *
  28.  *                                                                          *
  29.  ****************************************************************************/
  30.  
  31. options failat 20; options results
  32. arg inname inval
  33.  
  34. versionstr = "1.08"
  35. outp = 1; usereq = 1; output = stdout
  36. NL = '0A'x
  37.  
  38. signal on IOERR
  39.  
  40. /* parse command line options, to enable calling the script automatically,
  41.  * eg. from a function key
  42.  */
  43.  
  44. do while inname = '?'
  45.   writeln(stdout, "INFILE/A,QUIET/S,NOREQ/S ")
  46.   pull inname inval
  47. end
  48.  
  49. if inname ~= "" then do
  50.   if inname = "QUIET" | inname = "NOREQ" then do
  51.     inval = inname; inname = ""
  52.   end
  53. end
  54.  
  55. if inval = "QUIET" then do
  56.   outp = 0; usereq = 0
  57. end
  58. else if inval = "NOREQ" then usereq = 0
  59.  
  60. if usereq & ~show('l','rexxreqtools.library') then do
  61.   if exists('libs:rexxreqtools.library') then
  62.     call addlib('rexxreqtools.library',0,-30,0)
  63.   else do
  64.     usereq = 0; outp = 1
  65.     Tell("Unable to open rexxreqtools.library - using text output")
  66.   end
  67. end
  68.  
  69.  
  70. /* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
  71. if ~show('P','SCIONGEN') then do
  72.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  73.     'database is not available. Please start the' || NL ||,
  74.     'SCION program BEFORE using this script!')
  75. end
  76.  
  77. myport = "SCIONGEN"
  78. address value myport
  79. GETDBNAME
  80. dbname = upper(RESULT)
  81.  
  82. if outp & ~usereq then do
  83.   Tell("GEDCOM to Scion conversion script v"||versionstr||" by Freddy Ariës")
  84.   Tell("Scion (output) database: "||dbname)
  85. end
  86.  
  87. if inname = "" then do
  88.   /* ignore the value of outp; if we can't ask for the input file,
  89.    * we can't do anything!
  90.    */
  91.   if usereq then do
  92.     /* We need a file requester for further data */
  93.     inname = rtfilerequest('RAM:',,"GEDCOM Input File")
  94.   end
  95.   else do
  96.     Tell("Please enter the filename (with complete path) of the GEDCOM file:")
  97.     TellNN("Input file: ")
  98.     pull inname
  99.   end    
  100.   if inname = '' then
  101.     TermError("ERROR: No Input File!")
  102. end
  103.   
  104. if ~open(infile, inname, "r") then
  105.   TermError("ERROR: Input file '"inname"' not found!")
  106.  
  107. if ~open(errfile, dbname||".err", "w") then
  108.   errfile = stdout
  109.  
  110. if ~usereq then
  111.   Tell("Be patient - this may take a while...")
  112.  
  113. /* Initialize line count, individual counter and family counter */
  114. ink = GetNextLine()
  115. if left(ink, 6) ~= "0 HEAD" then do
  116.   close(infile)
  117.   TermError("ERROR: Invalid beginning of file - not a valid GEDCOM format")
  118. end
  119.  
  120. lvlstr = '0'; lvl = 1; atlvl = 1
  121. IRNArr. = 0; FGRNArr. = 0
  122.  
  123. /* Read the "HEAD" section until we find something else of level "0" */
  124.  
  125. prstot = ""
  126. ink = ParseHeader(atlvl)
  127. GETPROGVERSION
  128. prsr = RESULT
  129. prsr = "Destination:   Scion Genealogist "||prsr
  130. if ~usereq then
  131.   Tell(prsr)
  132. else
  133.   prstot = prstot||prsr||NL
  134. prsr = "Dest. file:    "||dbname
  135. if ~usereq then
  136.   Tell(prsr)
  137. else do
  138.   prstot=prstot||prsr||NL||NL||"Parsing will take a while - be patient."||,
  139.     NL||"Click to start parsing..."
  140.   rtezrequest(prstot,'_Continue','Converter Message:')
  141. end
  142.  
  143. /* Now scan the following level "0" fields for individuals;
  144.  * skip the families, for the moment
  145.  */
  146.  
  147. irn = 0
  148.  
  149. replay = 0
  150. do while ~eof(infile)
  151.   lvlstr = word(ink, 1)
  152.   lvl = GetNumType(lvlstr)
  153.  
  154.   if lvl = atlvl then do
  155.     tagstr = upper(word(ink, words(ink)))
  156.     if tagstr = "INDI" then do
  157.       nstr = strip(word(ink, 2),'B','@'||xrange('A','Z'))
  158.       if DATATYPE(nstr) = 'NUM' then do
  159.         tp = GGetIRN(nstr)
  160.         if tp ~= 0 then
  161.           writeln(errfile, "ERROR: Duplicate person encountered: "||nstr||" (IRN "||tp||")")
  162.         irn = irn + 1
  163.         ink = ParsePerson(nstr, lvl)
  164.         if ink ~= "" then replay = 1
  165.       end
  166.       else TermError("ERROR: Cannot determine the Individual Record Number!")
  167.     end
  168.   end
  169.   /* Skip all lines with level ~= current level (0) */
  170.   if replay = 0 then ink = GetNextLine()
  171.   else replay = 0
  172. end
  173.  
  174. if ~usereq then do
  175.   Tell("Number of persons parsed: "||irn)
  176.   GETTOTALIRN
  177.   tot = RESULT
  178.   Tell("Total number of persons in the Scion database: "||tot)
  179. end
  180.  
  181. /* Now rescan the entire file for families; I know it is quite
  182.  * inefficient this way, but it's better to add all the persons first,
  183.  * and then establish the relations...
  184.  */
  185.  
  186. close(infile)
  187. if ~open(infile, inname, "r") then
  188.   TermError("ERROR: Unable to read relations!")
  189.  
  190. if ~usereq then
  191.   Tell("Scanning file again to establish relations...")
  192.  
  193. lvlstr = '0'; lvl = 1; atlvl = 1
  194. fgrn = 0
  195.  
  196. replay = 0
  197. do while ~eof(infile)
  198.   if replay = 0 then ink = GetNextLine()
  199.   else replay = 0
  200.  
  201.   lvlstr = word(ink, 1)
  202.   lvl = GetNumType(lvlstr)
  203.  
  204.   if lvl = atlvl then do
  205.     tagstr = upper(word(ink, words(ink)))
  206.     if tagstr = "FAM" then do
  207.       nstr = strip(word(ink, 2),'B','@'||xrange('A','Z'))
  208.       if DATATYPE(nstr) = 'NUM' then do
  209.         fp = GGetFGRN(nstr)
  210.         if fp ~= 0 then
  211.           writeln(errfile, "ERROR: Duplicate family encountered: "||nstr||" (FGRN "||fp||")")
  212.         fgrn = fgrn + 1
  213.         ink = ParseFamily(nstr, lvl)
  214.         if ink ~= "" then replay = 1
  215.       end
  216.       else TermError("ERROR: Cannot determine the Family Group Record Number!")
  217.     end
  218.     else if tagstr = "TRLR" then do
  219.       close(infile)
  220.       GETTOTALFGRN
  221.       ftot = RESULT
  222.       if usereq then do
  223.     GETTOTALIRN
  224.     itot = RESULT
  225.         TermError("PARSING DONE:"||NL||"Number of persons parsed: "||irn||,
  226.       NL||"Total number of persons in the Scion database: "||itot||,
  227.           NL||"Number of families parsed: "||fgrn||,
  228.       NL||"Total number of families in the Scion database: "||ftot||,
  229.       NL||NL||"DON'T FORGET TO SAVE YOUR SCION FILE!!!")
  230.       end
  231.       else do
  232.     Tell("Number of families parsed: "||fgrn)
  233.     Tell("Total number of families in the Scion database: "||ftot)
  234.         TermError("DONE! DON'T FORGET TO SAVE YOUR SCION FILE!!!")
  235.       end
  236.     end
  237.   end
  238.   /* Skip all the fields at lvl ~= this level */
  239. end
  240. close(infile)
  241. if ink ~= "0 TRLR" then
  242.   TermError("ERROR: Unexpected end of file")
  243. else
  244.   TermError("ERROR: Trailer not recognized!")
  245.  
  246. ParseHeader: PROCEDURE EXPOSE infile prstot NL outp usereq
  247. parse arg inilvl
  248. do while ~eof(infile)
  249.   ins = GetNextLine()
  250.   if ins = "" then
  251.     TermError("ERROR: Unexpected end of file")
  252.   lvlstr = word(ins, 1)
  253.   lvl = GetNumType(lvlstr)
  254.   if lvl <= inilvl then RETURN ins
  255.   if lvl = inilvl+1 then do
  256.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  257.     curr = upper(word(lstr, 1))
  258.     if curr = "SOUR" then do
  259.       lstr = strip(delstr(lstr, 1, length(curr)))
  260.       prsr = "Source system: "||lstr
  261.       if ~usereq then
  262.     Tell(prsr)
  263.       else
  264.         prstot = prstot||prsr||NL
  265.       ins = ParseSource(lvl)
  266.       lvlstr = word(ins, 1)
  267.       lvl = lvlstr + 1
  268.       if lvl <= inilvl then RETURN ins
  269.       if lvl = inilvl+1 then do
  270.         lstr = strip(delstr(ins, 1, length(lvlstr)))
  271.         curr = upper(word(lstr, 1))
  272.       end
  273.       else TermError("ERROR: This should never happen [1]")
  274.     end
  275.     if curr = "DATE" then do
  276.       lstr = strip(delstr(lstr, 1, length(curr)))
  277.       prsr = "Creation date: "||lstr
  278.       if ~usereq then
  279.     Tell(prsr)
  280.       else
  281.         prstot = prstot||prsr||NL
  282.     end
  283.     else if curr = "FILE" then do
  284.       lstr = strip(delstr(lstr, 1, length(curr)))
  285.       prsr = "Source file:   "||lstr
  286.       if ~usereq then
  287.     Tell(prsr)
  288.       else
  289.         prstot = prstot||prsr||NL
  290.     end
  291.     /* add COPR (copyright) and GEDC VERS parsing
  292.      */
  293.   end
  294. end
  295. TermError("ERROR: Unexpected end of file")
  296.  
  297. ParseSource: PROCEDURE EXPOSE infile prstot NL outp usereq
  298. parse arg namlvl
  299. /* Scan for "NAME" and "VERS" */
  300. do while ~eof(infile)
  301.   ins = GetNextLine()
  302.   if ins = "" then
  303.     TermError("ERROR: Unexpected end of file")
  304.   lvlstr = word(ins, 1)
  305.   lvl = GetNumType(lvlstr)
  306.   if lvl <= namlvl then RETURN ins
  307.   if lvl = namlvl+1 then do
  308.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  309.     curr = upper(word(lstr, 1))
  310.     if curr = "VERS" then do
  311.       lstr = strip(delstr(lstr, 1, length(curr)))
  312.       prsr = "Version:       "||lstr
  313.       if ~usereq then
  314.         Tell(prsr)
  315.       else
  316.         prstot = prstot||prsr||NL
  317.     end
  318.     else if curr = "NAME" then do
  319.       lstr = strip(delstr(lstr, 1, length(curr)))
  320.       prsr = "Created by:    "||lstr
  321.       if ~usereq then
  322.         Tell(prsr)
  323.       else
  324.         prstot = prstot||prsr||NL
  325.     end
  326.   end
  327. end
  328. TermError("ERROR: Unexpected end of file")
  329.  
  330. ParsePerson: PROCEDURE EXPOSE infile IrnArr. errfile outp usereq
  331. parse arg pnum, inilvl
  332. replay = 0
  333. prn = GetNewPerson()
  334. IRNArr.pnum = prn
  335. do while ~eof(infile)
  336.   if replay = 0 then ins = GetNextLine()
  337.   else replay = 0
  338.   if ins = "" then
  339.     TermError("ERROR: Unexpected end of file")
  340.  
  341.   lvlstr = word(ins, 1)
  342.   lvl = GetNumType(lvlstr)
  343.   if lvl <= inilvl then RETURN ins
  344.   if lvl = inilvl + 1 then do
  345.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  346.     curr = upper(word(lstr, 1))
  347.   end
  348.  
  349.   if curr = "NAME" then StorePersName(strip(delstr(lstr, 1, length(curr))), prn)
  350.   else if curr = "SEX" then StorePersSex(strip(delstr(lstr, 1, length(curr))), prn)
  351.   else if curr = "BIRT" | curr = "DEAT" | curr = "BURI" then do
  352.     ins = ParsePersDatePlace(curr, prn, lvl)
  353.     replay = 1    
  354.   end
  355.   else if curr = "OCCU" then StoreUser1(strip(delstr(lstr, 1, length(curr))), prn)
  356.   else if curr = "NOTE" then do
  357.     ins = StoreUser2(strip(delstr(lstr, 1, length(curr))), prn, lvl)
  358.     replay = 1
  359.   end
  360.   else
  361.     writeln(errfile, "SKIPPED: Field "||curr||" for person "||prn||"!")
  362. end
  363. TermError("ERROR: Unexpected end of file")
  364.  
  365. ParseFamily: PROCEDURE EXPOSE infile FGRNArr. IRNArr. errfile outp usereq
  366. parse arg fnum, inilvl
  367. replay = 0
  368. do while ~eof(infile)
  369.   if replay = 0 then ins = GetNextLine()
  370.   else
  371.     replay = 0
  372.   if ins = "" then
  373.     TermError("ERROR: Unexpected end of file!")
  374.  
  375.   lvlstr = word(ins, 1)
  376.   lvl = GetNumType(lvlstr)
  377.   if lvl <= inilvl then RETURN ins
  378.   if lvl = inilvl + 1 then do
  379.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  380.     curr = upper(word(lstr, 1))
  381.   end
  382.  
  383.   if curr = "HUSB" then StoreFamHusband(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fnum)
  384.   else if curr = "WIFE" then StoreFamWife(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fnum)
  385.   else if curr = "CHIL" then StoreFamChild(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fnum)
  386.   else if curr = "MARR" then do
  387.     ins = ParseFamDatePlace(curr, fnum, lvl)
  388.     replay = 1
  389.   end
  390.   else if curr = "NOTE" then do
  391.     ins = StoreFamUser2(strip(delstr(lstr, 1, length(curr))), fnum, lvl)
  392.     replay = 1
  393.   end
  394.   else
  395.     writeln(errfile, "SKIPPED field "||curr||" in family "||fnum||"!")
  396. end
  397. TermError("ERROR: Unexpected end of file!")
  398.  
  399. GetNumType: PROCEDURE EXPOSE outp infile usereq
  400. parse arg str
  401. if DATATYPE(str) ~= 'NUM' then
  402.   TermError("ERROR: Level indicator expected -> error in GEDCOM specification? String is "||str)
  403. return str + 1
  404.  
  405. GetNextLine: PROCEDURE EXPOSE infile outp usereq
  406. ins = ""
  407. do while ins = "" & ~eof(infile)
  408.   ins = readln(infile)
  409.   if ins ~= "" then ins = strip(ins)
  410.   /* so we can check if strip(ins) is still ~= "" */
  411. end
  412. return ins
  413.  
  414. StorePersName: PROCEDURE
  415. parse arg nstr, pnum
  416. nstr = strip(nstr, 'B', '/')
  417. ps = pos('/', nstr)
  418. if ps = 0 then do
  419.   fname = ""
  420.   lname = nstr
  421. end
  422. else do
  423.   fname = left(nstr, ps-1)
  424.   lname = right(nstr, length(nstr)-ps)
  425. end
  426. PUTLASTNAME pnum lname
  427. PUTFIRSTNAME pnum fname
  428. return 1
  429.  
  430. StorePersSex: PROCEDURE
  431. parse arg nstr, pnum
  432.  sxstr = upper(left(nstr, 1))
  433.  if sxstr ~= 'M' then sxstr = 'F'
  434. PUTSEX pnum sxstr
  435. return 1
  436.  
  437. ParsePersDatePlace: PROCEDURE EXPOSE infile outp usereq
  438. parse arg idstr, pnum, inilvl
  439. datstr = ""
  440. plcstr = ""
  441. do while ~eof(infile)
  442.   ins = GetNextLine()
  443.   if eof(infile) then
  444.     TermError("ERROR: Unexpected end of file at (3)!")
  445.   lvlstr = word(ins, 1)
  446.   lvl = GetNumType(lvlstr)
  447.   if lvl <= inilvl then do
  448.     select
  449.       when idstr = "BIRT" then do
  450.     if datstr ~= "" then
  451.       PUTBIRTHDATE pnum datstr
  452.     if plcstr ~= "" then
  453.       PUTBIRTHPLACE pnum plcstr
  454.       end
  455.       when idstr = "DEAT" then do
  456.     if datstr ~= "" then
  457.       PUTDEATHDATE pnum datstr
  458.     if plcstr ~= "" then
  459.       PUTDEATHPLACE pnum plcstr
  460.       end
  461.       when idstr = "BURI" then do
  462.     if datstr ~= "" then
  463.       PUTBURIALDATE pnum datstr
  464.     if plcstr ~= "" then
  465.       PUTBURIALPLACE pnum plcstr
  466.       end
  467.       otherwise
  468.         /* do nothing */
  469.     end
  470.     /* "BIRT", "DEAT" or "BURI" event */
  471.     RETURN ins
  472.   end
  473.   if lvl = inilvl+1 then do
  474.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  475.     curr = upper(word(lstr, 1))
  476.     if curr = "DATE" then do
  477.       datstr = strip(delstr(lstr, 1, length(curr)))
  478.     end
  479.     else if curr = "PLAC" then do
  480.       plcstr = strip(delstr(lstr, 1, length(curr)))
  481.     end
  482.     else if curr = "QUAY" then do
  483.       lstr = strip(delstr(lstr, 1, length(curr)))
  484.       if DATATYPE(lstr) = 'NUM' & lstr < 2 then do
  485.         if datstr ~= "" then datstr = datstr||'?'
  486.         if plcstr ~= "" then plcstr = plcstr||'?'
  487.       end
  488.     end
  489.   end
  490.   /* Skip all fields of lvl > inilvl */
  491. end
  492. return 0
  493.  
  494. ParseFamDatePlace: PROCEDURE EXPOSE infile errfile FGRNArr. outp usereq
  495. parse arg idstr, fnum, inilvl
  496. datstr = ""; plcstr = ""
  497. ff = GGetFGRN(fnum)
  498. if ff = 0 then
  499.   writeln(errfile, "ERROR: Family Not Found: "||fnum||" when parsing date")
  500. do while ~eof(infile)
  501.   ins = GetNextLine()
  502.  
  503.   if ins = "" then
  504.     TermError("ERROR: Unexpected end of file (Parsing Family Events)!")
  505.  
  506.   lvlstr = word(ins, 1)
  507.   lvl = GetNumType(lvlstr)
  508.   if lvl <= inilvl then do
  509.     if idstr = "MARR" & ff ~= 0 then do
  510.       if datstr ~= "" then
  511.     PUTMARRYDATE ff datstr
  512.       if plcstr ~= "" then
  513.     PUTMARRYPLACE ff plcstr
  514.     end
  515.     RETURN ins
  516.   end
  517.   if lvl = inilvl+1 then do
  518.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  519.     curr = upper(word(lstr, 1))
  520.     if curr = "DATE" then do
  521.       datstr = strip(delstr(lstr, 1, length(curr)))
  522.     end
  523.     else if curr = "PLAC" then do
  524.       plcstr = strip(delstr(lstr, 1, length(curr)))
  525.     end
  526.     else if curr = "QUAY" then do
  527.       lstr = strip(delstr(lstr, 1, length(curr)))
  528.       if DATATYPE(lstr) = 'NUM' & lstr <= 1 then do
  529.         if datstr ~= "" then datstr = datstr||'?'
  530.         if plcstr ~= "" then plcstr = plcstr||'?'
  531.       end
  532.     end
  533.   end
  534.   /* Skip all fields of lvl > inilvl */
  535. end
  536. TermError("ERROR: Unexpected end of file (Parsed Family Events)!")
  537.  
  538. GetNewPerson: PROCEDURE EXPOSE infile outp usereq
  539.   PUTNEWPERSON
  540.   newpnum = RESULT
  541.   if newpnum = 0 then TermError("ERROR: Cannot allocate new person!")
  542.   /* if you want to see Scion in action, uncomment the next line */
  543.   /* GETPERSONWIN newpnum */
  544. return newpnum
  545.  
  546. GetNewFamily: PROCEDURE EXPOSE infile outp usereq
  547. parse arg irn
  548.   PUTNEWFAMILY irn
  549.   newfnum = RESULT
  550.   if newfnum = 0 then TermError("ERROR: Cannot allocate new family!")
  551.   /* if you want to see Scion in action, uncomment the next line */
  552.   /* GETFAMILYWIN newfnum */
  553. return newfnum
  554.  
  555. StoreUser1: PROCEDURE
  556. parse arg nstr, pnum
  557.  PUTPERSUSER1 pnum nstr
  558.  /* default: OCCUPATION */
  559. return 1
  560.  
  561. StoreUser2: PROCEDURE EXPOSE infile outp usereq
  562. parse arg nstr, pnum, lvl
  563.  PUTPERSUSER2 pnum nstr
  564.  /* default: COMMENTS */
  565.  l1 = lvl||" CONT"
  566.  l2 = length(l1)
  567.  ins = GetNextLine()
  568.  if length(ins) > l2 & left(ins, l2) = l1 then do
  569.    StoreUser3(right(ins, length(ins)-l2), pnum)
  570.    ins = GetNextLine()
  571.  end
  572. return ins
  573.  
  574. StoreUser3: PROCEDURE
  575. parse arg nstr, pnum
  576.  PUTPERSUSER3 pnum nstr
  577.  /* default: REFERENCES */
  578. return 1
  579.  
  580. StoreFamHusband: PROCEDURE EXPOSE IRNArr. FGRNArr. errfile infile outp usereq
  581. parse arg nstr, fnum
  582.   nstr = strip(nstr,'B','@'||xrange('A','Z'))
  583.   if DATATYPE(nstr) = 'NUM' then
  584.   do
  585.     ii = GGetIRN(nstr)
  586.     if ii = 0 then
  587.       writeln(errfile, "ERROR: Missing Personal Record for HUSBAND "||nstr)
  588.     else do
  589.       ff = GGetFGRN(fnum)
  590.       if ff = 0 then do
  591.     /* This goes wrong for multiple marriages */
  592.         ff = GetNewFamily(ii)
  593.         FGRNArr.fnum = ff
  594.       end
  595.       else do
  596.     /* There is already a family, so there is a principal; assume
  597.      * that that is the wife - add the husband as spouse
  598.      */
  599.         PUTSPOUSE ff ii
  600.     ers = RESULT
  601.     if ers ~= 1 then do
  602.           writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (HUSB) "||ff||' '||ii)
  603.       GETPRINCIPAL ff
  604.       prc = RESULT
  605.       GETSPOUSE ff
  606.       spc = RESULT
  607.       writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
  608.     end
  609.       end
  610.     end
  611.   end
  612. return 1
  613.  
  614. StoreFamWife: PROCEDURE EXPOSE IRNArr. FGRNArr. errfile infile outp usereq
  615. parse arg nstr, fnum
  616.   nstr = strip(nstr,'B','@'||xrange('A','Z'))
  617.   if DATATYPE(nstr) = 'NUM' then
  618.   do
  619.     ii = GGetIRN(nstr)
  620.     if ii = 0 then
  621.       writeln(errfile, "ERROR: Missing Personal Record for WIFE "||nstr)
  622.     else do
  623.       ff = GGetFGRN(fnum)
  624.       if ff = 0 then do
  625.         ff = GetNewFamily(ii)
  626.         FGRNArr.fnum = ff
  627.       end
  628.       else do
  629.         PUTSPOUSE ff ii
  630.     ers = RESULT
  631.     if ers ~= 1 then do
  632.           writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (WIFE) "||ff||' '||ii)
  633.       GETPRINCIPAL ff
  634.       prc = RESULT
  635.       GETSPOUSE ff
  636.       spc = RESULT
  637.       writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
  638.     end
  639.       end
  640.     end
  641.   end
  642. return 1
  643.  
  644. StoreFamChild: PROCEDURE EXPOSE IRNArr. FGRNArr. errfile infile outp usereq
  645. parse arg nstr, fnum
  646.   nstr = strip(nstr,'B','@'||xrange('A','Z'))
  647.   if DATATYPE(nstr) = 'NUM' then
  648.   do
  649.     ii = GGetIRN(nstr)
  650.     if ii = 0 then
  651.       writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr)
  652.     else do
  653.       ff = GGetFGRN(fnum)
  654.       if ff = 0 then do
  655.         writeln(errfile, "ERROR: Family for child "||ii||" doesn't exist! Child SKIPPED!")
  656.       end
  657.       else do
  658.         PUTCHILD ff ii
  659.     ers = RESULT
  660.     if ers ~= 1 then
  661.           writeln(errfile, "ERROR "||ers||" in PUTCHILD "||ff||' '||ii)
  662.       end
  663.     end
  664.   end
  665. return 1
  666.  
  667. StoreFamUser1: PROCEDURE EXPOSE infile outp usereq
  668. parse arg nstr, fnum
  669. if fnum ~= 0 then
  670.   PUTFAMUSER1 fnum nstr
  671.  /* Default: CELEBRANT, but I use it as a CONT field for comments */
  672. return 1
  673.  
  674. StoreFamUser2: PROCEDURE EXPOSE infile outp usereq FGRNArr.
  675. parse arg nstr, fnum, lvl
  676.  fid = GGetFGRN(fnum)
  677.  if fid ~= 0 then
  678.    PUTFAMUSER2 fid nstr
  679.  /* Default: COMMENTS */
  680.  l1 = lvl||" CONT"
  681.  l2 = length(l1)
  682.  ins = GetNextLine()
  683.  if length(ins) > l2 & left(ins, l2) = l1 then do
  684.    StoreFamUser1(right(ins, length(ins)-l2), fid)
  685.    ins = GetNextLine()
  686.  end
  687. return ins
  688.  
  689. /* Return the Scion IRN belonging to the GEDCOM Personal number pnum */
  690. /* If there is no entry yet, allocate one! */
  691. GGetIRN: PROCEDURE EXPOSE IRNArr.
  692. parse arg pnum
  693. return IRNArr.pnum
  694.  
  695. /* Return the Scion FGRN belonging to the GEDCOM Family number fnum */
  696. GGetFGRN: PROCEDURE EXPOSE FGRNArr.
  697. parse arg fnum
  698. if FGRNArr.fnum = '' then
  699.   writeln(stdout, "ERROR: empty field in FGRN Array")
  700. return FGRNArr.fnum
  701.  
  702. Tell: PROCEDURE EXPOSE outp
  703. parse arg str
  704. if outp then writeln(stdout, str)
  705. return 0
  706.  
  707. TellNN: PROCEDURE EXPOSE outp
  708. parse arg str
  709. if outp then writech(stdout, str)
  710. return 0
  711.  
  712. TermError: PROCEDURE EXPOSE infile outp usereq
  713. parse arg str
  714. /* If you turned off stdout, no error messages will be shown! */
  715. if usereq then
  716.   rtezrequest(str,'E_xit','Converter Message:')
  717. else do
  718.   Tell(str || '0A'x)
  719. end
  720. close(infile)
  721. EXIT
  722.  
  723. /* Let's make sure you get a nice message when you turn off the printer :-) */
  724.  
  725. IOERR:
  726.   bline = SIGL
  727.   say "I/O error #"||RC||" detected in line "||bline||":"
  728.   say sourceline(bline)
  729.   EXIT
  730.